home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / v3_1 / sbp3_1c.lzh / prolog3.1 / modlib / src / $decompile.P < prev    next >
Text File  |  1991-11-23  |  21KB  |  620 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25. /* This file contains predicates that traverse a buffer containing
  26.    asserted code, and reconstruct the clause that was asserted.  This
  27.    code is tied fairly tightly to the code generated by "assert", so
  28.    changes to assert may require corresponding updates to this code.
  29.    This also means that compiled code (i.e. that generated by "compile")
  30.    cannot be decompiled.                    */
  31.  
  32. $decompile_export([$clause/2,$clause/3,$listing/1,$instance/2,$listing/0]).
  33.  
  34. $decompile_use($bio, [$writename/1,_,_,$nl/0,_,$tell/1,_,$telling/1,
  35.               $told/0,_,_,_,_,_,_]).
  36. $decompile_use($buff, [_,_,_,$buff_code/4,$symtype/2,_,_,_,_,_,_]).
  37. $decompile_use($bmeta,[_,_,_,_,_,_,_,_,$arity/2,_,_,$mkstr/3,$is_buffer/1]).
  38. $decompile_use($meta,[$functor/3,_,_]).
  39. $decompile_use($assert,[_,_,_,_,_,_,_,_,_,_,$assert_get_prref/2,_,_]).
  40. $decompile_use($blist,[$append/3,_,$memberchk/2,_]).
  41. $decompile_use($deb,[$debug/0,$nodebug/0,_,_,_,_,_,_,_,_,_,$deb_set/3,
  42.          $deb_unset/1]).
  43. $decompile_use($currsym,[_,_,$predicate_property/2,_,_,_,_,_]).
  44.  
  45.  
  46. $clause(Hd,Body) :- $clause(Hd,Body,_,1).
  47.  
  48. $clause(Hd,Body,Ref) :- $clause(Hd,Body,Ref,1).
  49.  
  50. $clause(Hd,Body,Ref,Xform) :-
  51.      nonvar(Hd),
  52.      !,
  53.      $decompile(Hd, Body, Ref, Xform).
  54. $clause(Hd,Body,Ref,Xform) :-
  55.      $is_buffer(Ref),    /* better be a DB ref! */
  56.      $dec_getpsc(Ref,16,_,Psc),
  57.      $mkstr(Psc,Hd0,Arity),
  58.      !,
  59.      $decompile_clause(Ref,Arity,Hd0,Body0),
  60.      (Body0 ?= true ->
  61.           (Hd = Hd0, Body = Body0) ;
  62.       (arg(Arity,Hd0,CutArg),
  63.        $dec_xform(Body0,CutArg,Body,Xform),
  64.        RArity is Arity - 1,
  65.        $functor(Hd0,Pred,_), $functor(Hd,Pred,RArity),
  66.        $dec_copyargs(RArity,Hd0,Hd)
  67.       )
  68.      ).
  69. $clause(Hd,B,R,_) :-
  70.      $telling(X), $tell(stderr),
  71.      $writename('*** Error: illegal argument(s) to clause/[2,3]: <'), 
  72.      $write(Hd), $write(', '), $write(B), $write(', '), $write(R), $write('> ***'), $nl,
  73.      $told, $tell(X),
  74.      fail.
  75.  
  76. $listing :-
  77.      $predicate_property(X,interpreted),
  78.      $functor(X,P,N),
  79.      $listing(P/N),
  80.      fail.
  81. $listing.
  82.  
  83. $listing(Pred) :- $listing(Pred,1).
  84.  
  85. $listing([],_) :- !.
  86. $listing([H|L],Xform) :-
  87.      !,
  88.      ($listing(H,Xform) -> true ; true),   /* do the rest anyway */
  89.      $listing(L,Xform).
  90. $listing(Pred,Xform) :-
  91.      nonvar(Pred) ->
  92.           (Pred = P/N ->
  93.            ($functor(Hd,P,N),
  94.             ($decompile(Hd,Body,_,Xform),
  95.              $portray_clause((Hd :- Body)),
  96.              fail    /* backtrack to get all clauses */
  97.             ) ;
  98.             true
  99.            ) ;
  100.            ($errmsg('*** Error: argument to listing/1 must be of the form <pred>/<arity>'), $nl
  101.            )
  102.       ) ;
  103.         ($errmsg('*** Error: argument to listing/1 must be instantiated ***'), fail).
  104.  
  105.  
  106. $instance(Ref, Instance) :-
  107.      $is_buffer(Ref) ->
  108.           $instance_1(Ref, Instance) ;
  109.       ($telling(X), $tell(stderr),
  110.        $write('*** Error: argument 1 of instance/2 must be a DB reference ***'), $nl,
  111.        $told, $tell(X),
  112.        fail
  113.       ).
  114.  
  115. $instance_1(Ref, Instance) :-
  116.      $clause(H, B, Ref),
  117.      (H = '_$record_db'(_, Instance) ->
  118.           true ;
  119.       Instance = (H :- B)
  120.      ).
  121.  
  122. $dec_getbuffwd(Buff,Li,Lo,Word) :-
  123.     Lo is Li+2, $buff_code(Buff,Li,6 /* gb */,Word).
  124.  
  125. $dec_getbuffnum(Buff,Li,Lo,Num) :-
  126.     Lo is Li+4, $buff_code(Buff,Li,5 /* gn */,Num).
  127.  
  128. $dec_getbuffloat(Buff,Li,Lo,Num) :-
  129.     Lo is Li+4, $buff_code(Buff,Li,29 /* gf */,Num).
  130.  
  131. $dec_getpsc(Buff,Li,Lo,Psc) :-
  132.     Lo is Li+4, $buff_code(Buff,Li,28 /* gppsc */, Psc).
  133.  
  134. $decompile(Head, Body, Clref, Xform) :-
  135.      $functor(Head,P,N),
  136.      $symtype(Head, Type),
  137.      (Type =\= 1 ->
  138.           ($dec_errmsg(Type,P,N), fail) ;
  139.       ($dec_GetPrref(Head,Prref),
  140.            $buff_code(Prref,8,8 /* gpb */, FirstClref),
  141.        $clause_addr(FirstClref, Clref,P,N),
  142.        NArity is N + 1,    /* extra argument introduced during assert
  143.                       to handle cuts */
  144.            $functor(NHd,P,NArity),
  145.        $dec_copyargs(N,Head,NHd),
  146.        arg(NArity,NHd,CutArg),
  147.        $decompile_clause(Clref, NArity, NHd, Body0),
  148.        $dec_xform(Body0,CutArg,Body,Xform)
  149.       )
  150.      ).
  151.  
  152. $dec_GetPrref(Head,Prref) :-
  153.      $assert_get_prref(Head, Prref0),
  154.      $dec_getbuffwd(Prref0,4,_,Op),
  155.      (Op =:= 91 /* jumptbreg */ ->  /* clause present, no interception */
  156.           Prref = Prref0 ;
  157.       (Op =:= 92 /* unexec */ ->  /* call intercept: trace/ET &c. */
  158.            ($functor(Head,P,N), Pred = P/N,
  159.             $dec_undo_inters(Pred,Inters),
  160.         $dec_GetPrref(Head,Prref),
  161.         $dec_do_inters(Inters,P,N)
  162.            )
  163.      )
  164.      ).
  165.  
  166. $dec_undo_inters(Pred,Inters) :-   /* undo effects of call interception */
  167.      (($symtype('_$traced_preds'(_),TType),
  168.        TType > 0,
  169.        '_$traced_preds'(Pred)
  170.       ) ->
  171.           (Inters = [trace|I0], $deb_unset(Pred)) ;
  172.       Inters = I0
  173.      ),
  174.      (($symtype('_$spy_points'(_),SType),
  175.        SType > 0,
  176.        '_$spy_points'(Pred)
  177.       ) ->
  178.           (I0 = [spy|I1], $deb_unset(Pred)) ;
  179.       I0 = I1
  180.      ),
  181.      (($symtype($deb_ugging(_),DType),
  182.        DType > 0
  183.       ) ->
  184.            (I1 = [debugging(X)], $deb_ugging(X)) ;
  185.        I1 = []
  186.      ).
  187.  
  188. $dec_do_inters([],P,A).
  189. $dec_do_inters([I|IRest],P,A) :-
  190.      $dec_do_inters1(I,P,A), $dec_do_inters(IRest,P,A).
  191.  
  192. $dec_do_inters1(trace,P,A) :- $deb_set(P,A,$deb_trace(_)).
  193. $dec_do_inters1(spy,  P,A) :- $deb_set(P,A,$deb_spy(_)).
  194. $dec_do_inters1(debugging(X),_,_) :- X =:= 1 -> $debug ; $nodebug.
  195.  
  196. /* $clause_addr/4 takes the reference of the first clause for a predicate,
  197.    and returns the reference of a clause for the predicate, backtracking
  198.    successively through all of them.                    */
  199.  
  200. $clause_addr(CurrClref,Clref,P,N) :-
  201.      $buff_code(CurrClref,4,6 /* gb */, Sop),
  202.      ((Sop =:= 44 ; Sop =:= 85) ->     /* trustmeelsefail or noop */
  203.           $clause_addr1(CurrClref,Clref,P,N) ;
  204.       ((Sop =:= 42 ; Sop =:= 43) -> /* trymeelse or retrymeelse */
  205.            ($buff_code(CurrClref,8,8 /* gpb */, NextClref),
  206.             ($clause_addr1(CurrClref,Clref,P,N) ;
  207.          $clause_addr(NextClref, Clref,P,N)  /* get next clause */
  208.         )
  209.            )
  210.      )
  211.      ).
  212.  
  213. $clause_addr1(CurrCl,Cl,P,N) :-
  214.      $buff_code(CurrCl,20,6 /* gb */,55) ->    /* check if SOB-buffer */
  215.          ($buff_code(CurrCl,36,8 /* gpb */,Clref),
  216.       $clause_addr(Clref,Cl,P,N)
  217.      ) ;
  218.      ($buff_code(CurrCl,12,6 /* gb */,77 /* jump */) ->
  219.           ($telling(X), $tell(stderr),
  220.            $writename('*** Warning: '),
  221.                $writename(P), $writename('/'), $writename(N),
  222.                $writename(' contains compiled code that is not being decompiled ***'), $nl,
  223.                $told, $tell(X),
  224.            fail
  225.           ) ;
  226.           Cl = CurrCl
  227.          ).
  228.  
  229. $decompile_clause(Clref, N, Head, Body) :-
  230.      $buff_code(Clref,12,6 /* gb */, Op),
  231.      $opcode(fail, FailOp),
  232.      Op =\= FailOp, /* make sure the clause hasn't been erased */
  233.      $dec_mk_rmap(4,4,Rmap0),
  234.      $decompile_head(Clref,1,N,Head,20,Lm,Rmap0,Rmap1),
  235.      $decompile_body(Clref,Body,Lm,Rmap1).
  236.  
  237. $decompile_head(Buff,Arg,Arity,Term,Li,Lo,Rmap0,Rmap1) :-
  238.      Arg > Arity ->
  239.           (Li = Lo, Rmap0 = Rmap1) ;
  240.            ($dec_getbuffwd(Buff,Li,Lm0,Op),
  241.        $dec_argreg(Op,Buff,Lm0,Reg),
  242.        (Reg =:= Arg ->
  243.             $dec_hdarg(Op,Buff,Term,Lm0,Lm1,Rmap0,Rmap2) ;
  244.         (Lm1 = Li, Rmap2 = Rmap0,
  245.          $dec_map_lookup(Arg,Rmap0,X),
  246.          arg(Arg,Term,X)
  247.         )
  248.        ),
  249.        NextArg is Arg+1,
  250.        $decompile_head(Buff,NextArg,Arity,Term,Lm1,Lo,Rmap2,Rmap1)
  251.       ).
  252.  
  253. $dec_hdarg(3,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
  254.     Li1 is Li+2,    /* skip pad word */
  255.     $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
  256.     $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
  257.     arg(Arg1,Term,T), arg(Arg2,Term,T),
  258.     $dec_map_lookup(Arg1,Rmap,T),
  259.     $dec_map_lookup(Arg2,Rmap,T).
  260. $dec_hdarg(4,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
  261.     $dec_getbuffwd(Buff,Li,Lm,Arg),
  262.     arg(Arg,Term,Const),
  263.     $dec_getpsc(Buff,Lm,Lo,Const),
  264.     $dec_map_lookup(Arg,Rmap,Const).
  265. $dec_hdarg(5,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
  266.     $dec_getbuffwd(Buff,Li,Lo,Arg),
  267.     arg(Arg,Term,[]),
  268.     $dec_map_lookup(Arg,Rmap,[]).
  269. $dec_hdarg(6,Buff,Term,Li,Lo,R0,R1) :-        /* getstr(Str,N) */
  270.     $dec_getbuffwd(Buff,Li,Lm1,Arg),
  271.     $dec_getpsc(Buff,Lm1,Lm2,Func),
  272.     $mkstr(Func,Str,Arity),
  273.     arg(Arg,Term,Str),
  274.     $dec_subs(1,Arity,Buff,Str,Lm2,Lo,R0,R1),
  275.     $dec_map_lookup(Arg,R1,Str).
  276. $dec_hdarg(7,Buff,Term,Li,Lo,R0,R1) :-        /* getlist(N) */
  277.     $dec_getbuffwd(Buff,Li,Lm1,Arg),
  278.     List = [_|_], arg(Arg,Term,List),
  279.     $dec_subs(1,2,Buff,List,Lm1,Lo,R0,R1),
  280.     $dec_map_lookup(Arg,R1,List).
  281. $dec_hdarg(14,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
  282.     $dec_getbuffwd(Buff,Li,Lm,Arg),
  283.     arg(Arg,Term,N),
  284.     $dec_getbuffnum(Buff,Lm,Lo,N),
  285.     $dec_map_lookup(Arg,Rmap,N).
  286. $dec_hdarg(32,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
  287.     $dec_getbuffwd(Buff,Li,Lm,Arg),
  288.     arg(Arg,Term,N),
  289.     $dec_getbuffloat(Buff,Lm,Lo,N),
  290.     $dec_map_lookup(Arg,Rmap,N).
  291. $dec_hdarg(39,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
  292.     $dec_getbuffwd(Buff,Li,Lm0,Arg),
  293.     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
  294.     $dec_getbuffwd(Buff,Lm1,Lo,R2),
  295.     $dec_map_lookup(R1,Rmap,A1),
  296.     $dec_map_lookup(R2,Rmap,A2),
  297.     Sub = [A1|A2], arg(Arg,Term,Sub),
  298.     $dec_map_lookup(Arg,Rmap,Sub).
  299. $dec_hdarg(40,Buff,Term,Li,Lo,R0,R1) :-        /* getcomma(N) */
  300.     $dec_getbuffwd(Buff,Li,Lm1,Arg),
  301.     Sub = ','(_,_), arg(Arg,Term,Sub),
  302.     $dec_subs(1,2,Buff,Sub,Lm1,Lo,R0,R1),
  303.     $dec_map_lookup(Arg,R1,Sub).
  304. $dec_hdarg(41,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
  305.     $dec_getbuffwd(Buff,Li,Lm0,Arg),
  306.     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
  307.     $dec_getbuffwd(Buff,Lm1,Lo,R2),
  308.     $dec_map_lookup(R1,Rmap,A1),
  309.     $dec_map_lookup(R2,Rmap,A2),
  310.     Sub = ','(A1,A2), arg(Arg,Term,Sub),
  311.     $dec_map_lookup(Arg,Rmap,Sub).
  312.  
  313. /* $dec_argreg/3 returns the "main" register number for an instruction in
  314.    a buffer.  Argument 1 is the opcode of the "current" instruction. */
  315.  
  316. $dec_argreg(3,Buff,Disp,N) :-            /* gettval(R,N) */
  317.      Lr is Disp + 4,        /* skip pad byte, op1 */
  318.      $buff_code(Buff,Lr,6 /* gb */, N).
  319. $dec_argreg(Op,Buff,Disp,N) :-
  320.      Op >= 4, Op =< 7, /* getcon(C,N)|getnil(N)|getstr(Str,N)|getlist(N) */
  321.      $buff_code(Buff,Disp,6 /* gb */, N).
  322. $dec_argreg(14,Buff,Disp,N) :-            /* getnumcon(Num,N) */
  323.      $buff_code(Buff,Disp,6 /* gb */, N).
  324. $dec_argreg(32,Buff,Disp,N) :-            /* getfloatcon(Num,N) */
  325.      $buff_code(Buff,Disp,6 /* gb */, N).
  326. $dec_argreg(Op,Buff,Disp,N) :-            
  327.      Op >= 39, /* getlist_tvar_tvar(N,_,_) | getcomma(N) | */
  328.      Op =< 41, /* getcomma_tvar_tvar(N,_,_) */
  329.      $buff_code(Buff,Disp,6 /* gb */, N).
  330.  
  331. /*  if we hit a "put" instruction we know we're past the head, so return an
  332.     "impossible" register number.                    */
  333. $dec_argreg(15,Buff,Disp,-1).        /* putnumcon(Num,N) */
  334. $dec_argreg(18,Buff,Disp,-1).        /* puttvar(T,R) */
  335. $dec_argreg(20,Buff,Disp,-1).        /* putcon(C,R) */
  336. $dec_argreg(21,Buff,Disp,-1).        /* putnil(R) */
  337. $dec_argreg(22,Buff,Disp,-1).        /* putstr(S,R) */
  338. $dec_argreg(23,Buff,Disp,-1).        /* putlist(R) */
  339. $dec_argreg(33,Buff,Disp,-1).        /* putfloatcon(Num,N) */
  340. $dec_argreg(58,Buff,Disp,-1).        /* movreg(T,R) */
  341. $dec_argreg(74,Buff,Disp,-1).        /* proceed */
  342. $dec_argreg(75,Buff,Disp,-1).        /* execute(P) */
  343.  
  344. $dec_subs(N,Arity,Buff,Term,Li,Lo,Rin,Rout) :-
  345.     N > Arity ->
  346.         (Li = Lo, Rin = Rout) ;
  347.     ($dec_getbuffwd(Buff,Li,Lm1,Op),
  348.      $dec_sub(Op,Buff,Sub,Lm1,Lm2,Rin,Rmid),
  349.      arg(N,Term,Sub),
  350.      N1 is N+1,
  351.      $dec_subs(N1,Arity,Buff,Term,Lm2,Lo,Rmid,Rout)
  352.     ).
  353.  
  354. $dec_sub(10,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitvar(R) */
  355.     $dec_getbuffwd(Buff,Li,Lo,R),
  356.     $dec_map_lookup(R,Rmap,X).
  357. $dec_sub(11,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitval(R) */
  358.     $dec_getbuffwd(Buff,Li,Lo,R),
  359.     $dec_map_lookup(R,Rmap,X).
  360. $dec_sub(12,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* unicon(Con) */
  361.     Lm is Li+2,    /* skip pad bytes */
  362.     $dec_getpsc(Buff,Lm,Lo,Con).
  363. $dec_sub(13,Buff,[],Li,Lo,Rmap,Rmap) :-        /* uninil */
  364.     Lo is Li + 2.
  365. $dec_sub(26,Buff,X,Li,Lo,Rin,Rout) :-        /* bldtvar(R) */
  366.     $dec_getbuffwd(Buff,Li,Lo,R),
  367.     $dec_map_update(R,Rin,X,Rout).
  368. $dec_sub(27,Buff,X,Li,Lo,Rmap,Rmap) :-        /* bldtval(R) */
  369.     $dec_getbuffwd(Buff,Li,Lo,R),
  370.     $dec_map_lookup(R,Rmap,X).
  371. $dec_sub(28,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* bldcon(Con) */
  372.     Lm is Li+2,    /* skip pad byte */
  373.     $dec_getpsc(Buff,Lm,Lo,Con).
  374. $dec_sub(29,Buff,[],Li,Lo,Rmap,Rmap) :-        /* bldnil */
  375.     Lo is Li + 2.
  376. $dec_sub(30,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* uninumcon(Num) */
  377.     Lm is Li+2,    /* skip pad bytes */
  378.     $dec_getbuffnum(Buff,Lm,Lo,Num).
  379. $dec_sub(31,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldnumcon(Num) */
  380.     Lm is Li+2,    /* skip pad bytes */
  381.     $dec_getbuffnum(Buff,Lm,Lo,Num).
  382. $dec_sub(34,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* unifloatcon(Num) */
  383.     Lm is Li+2,    /* skip pad bytes */
  384.     $dec_getbuffloat(Buff,Lm,Lo,Num).
  385. $dec_sub(35,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldfloatcon(Num) */
  386.     Lm is Li+2,    /* skip pad bytes */
  387.     $dec_getbuffloat(Buff,Lm,Lo,Num).
  388.  
  389.  
  390. $decompile_body(Buff,Body,Loc,Rmap) :-
  391.      $dec_getbuffwd(Buff,Loc,Lm0,Op),
  392.      (Op =:= 74 ->                /* proceed */
  393.           Body = true ;
  394.       (Op =:= 75 ->            /* execute(P) */
  395.            (Lm1 is Lm0 + 2,    /* skip pad bytes */
  396.             $dec_getpsc(Buff,Lm1,_,Psc),
  397.         $mkstr(Psc,Body,Arity),
  398.         $dec_procputs(Arity,Rmap,Body)
  399.            ) ;
  400.            ($dec_bodyinst(Op,Buff,Lm0,Lm1,Rmap,Rmap0),
  401.             $decompile_body(Buff,Body,Lm1,Rmap0)
  402.            )
  403.       )
  404.      ).
  405.  
  406. $dec_bodyinst(3,Buff,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
  407.      Li1 is Li+2,    /* skip pad bytes */
  408.      $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
  409.      $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
  410.      $dec_map_lookup(Arg1,Rmap,T),
  411.      $dec_map_lookup(Arg2,Rmap,T).
  412. $dec_bodyinst(4,Buff,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
  413.      $dec_getbuffwd(Buff,Li,Lm,R),
  414.      $dec_getpsc(Buff,Lm,Lo,Const),
  415.      $dec_map_lookup(R,Rmap,Const).
  416. $dec_bodyinst(5,Buff,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
  417.      $dec_getbuffwd(Buff,Li,Lo,R),
  418.      $dec_map_lookup(R,Rmap,[]).
  419. $dec_bodyinst(6,Buff,Li,Lo,Rin,Rout) :-        /* getstr(Str,N) */
  420.      $dec_getbuffwd(Buff,Li,Lm1,R),
  421.      $dec_getpsc(Buff,Lm1,Lm2,Func),
  422.      $mkstr(Func,Str,Arity),
  423.      $dec_map_lookup(R,Rin,Str),
  424.      $dec_subs(1,Arity,Buff,Str,Lm2,Lo,Rin,Rout).
  425. $dec_bodyinst(7,Buff,Li,Lo,Rin,Rout) :-        /* getlist(N) */
  426.      $dec_getbuffwd(Buff,Li,Lm1,R),
  427.      List = [_|_],
  428.      $dec_map_lookup(R,Rin,List),
  429.      $dec_subs(1,2,Buff,List,Lm1,Lo,Rin,Rout).
  430. $dec_bodyinst(14,Buff,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
  431.      $dec_getbuffwd(Buff,Li,Lm,R),
  432.      $dec_getbuffnum(Buff,Lm,Lo,N),
  433.      $dec_map_lookup(R,Rmap,N).
  434. $dec_bodyinst(15,Buff,Li,Lo,Rin,Rout) :-
  435.      $dec_getbuffwd(Buff,Li,Lm,R),        /* putnumcon(Num,R) */
  436.      $dec_getbuffnum(Buff,Lm,Lo,Num),
  437.      $dec_map_update(R,Rin,Num,Rout).
  438. $dec_bodyinst(18,Buff,Li,Lo,Rin,Rout) :-    /* puttvar(R1, R2) */
  439.      Li1 is Li + 2,
  440.      $dec_getbuffwd(Buff,Li1,Lm,R1),
  441.      $dec_getbuffwd(Buff,Lm,Lo,R2),
  442.      $dec_map_update(R1,Rin,X,Rmid),
  443.      $dec_map_update(R2,Rmid,X,Rout).
  444. $dec_bodyinst(20,Buff,Li,Lo,Rin,Rout) :-
  445.      $dec_getbuffwd(Buff,Li,Lm,R),        /* putcon(Con,R) */
  446.      $dec_getpsc(Buff,Lm,Lo,Con),
  447.      $dec_map_update(R,Rin,Con,Rout).
  448. $dec_bodyinst(21,Buff,Li,Lo,Rin,Rout) :- 
  449.      $dec_getbuffwd(Buff,Li,Lo,R),        /* putnil(R) */
  450.      $dec_map_update(R,Rin,[],Rout).
  451. $dec_bodyinst(22,Buff,Li,Lo,Rin,Rout) :-
  452.      $dec_getbuffwd(Buff,Li,Lm0,R),        /* putstr(Str,R) */
  453.      $dec_getpsc(Buff,Lm0,Lm1,Psc),
  454.      $mkstr(Psc,Str,Arity),
  455.      $dec_subs(1,Arity,Buff,Str,Lm1,Lo,Rin,Rmid),
  456.      $dec_map_update(R,Rmid,Str,Rout).
  457. $dec_bodyinst(23,Buff,Li,Lo,Rin,Rout) :- 
  458.      List = [_|_],                /* putlist(R) */
  459.      $dec_getbuffwd(Buff,Li,Lm,R),
  460.      $dec_map_update(R,Rin,List,Rmid),
  461.      $dec_subs(1,2,Buff,List,Lm,Lo,Rmid,Rout).
  462. $dec_bodyinst(32,Buff,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
  463.      $dec_getbuffwd(Buff,Li,Lm,R),
  464.      $dec_getbuffloat(Buff,Lm,Lo,N),
  465.      $dec_map_lookup(R,Rmap,N).
  466. $dec_bodyinst(33,Buff,Li,Lo,Rin,Rout) :-
  467.      $dec_getbuffwd(Buff,Li,Lm,R),        /* putfloatcon(Num,R) */
  468.      $dec_getbuffloat(Buff,Lm,Lo,Num),
  469.      $dec_map_update(R,Rin,Num,Rout).
  470. $dec_bodyinst(39,Buff,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
  471.      $dec_getbuffwd(Buff,Li,Lm0,R0),
  472.      $dec_getbuffwd(Buff,Lm0,Lm1,R1),
  473.      $dec_getbuffwd(Buff,Lm1,Lo,R2),
  474.      $dec_map_lookup(R1,Rmap,A1),
  475.      $dec_map_lookup(R2,Rmap,A2),
  476.      $dec_map_lookup(R0,Rmap,[A1|A2]).
  477. $dec_bodyinst(40,Buff,Li,Lo,Rin,Rout) :-    /* getcomma(N) */
  478.      $dec_getbuffwd(Buff,Li,Lm1,R),
  479.      Sub = ','(_,_), $dec_map_lookup(R,Rin,Sub),
  480.      $dec_subs(1,2,Buff,Sub,Lm1,Lo,Rin,Rout).
  481. $dec_bodyinst(41,Buff,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
  482.      $dec_getbuffwd(Buff,Li,Lm0,R0),
  483.      $dec_getbuffwd(Buff,Lm0,Lm1,R1),
  484.      $dec_getbuffwd(Buff,Lm1,Lo,R2),
  485.      $dec_map_lookup(R1,Rmap,A1),
  486.      $dec_map_lookup(R2,Rmap,A2),
  487.      $dec_map_lookup(R0,Rmap,','(A1,A2)).
  488. $dec_bodyinst(58,Buff,Li,Lo,Rin,Rout) :-      /* movreg(R1,R2) */
  489.      Lm0 is Li + 2,    /* skip pad bytes */
  490.      $dec_getbuffwd(Buff,Lm0,Lm1,R1),
  491.      $dec_getbuffwd(Buff,Lm1,Lo,R2),
  492.      $dec_map_lookup(R1,Rin,Val),
  493.      $dec_map_update(R2,Rin,Val,Rout).
  494.  
  495. $dec_procputs(Arg,Rmap,Body) :-
  496.      Arg =:= 0 ->
  497.           true ;
  498.       ($dec_map_lookup(Arg,Rmap,Val),
  499.        arg(Arg,Body,Val),
  500.        Next is Arg - 1,
  501.        $dec_procputs(Next,Rmap,Body)
  502.       ).
  503.  
  504. $dec_xform(Body0,C,Body1,N) :-
  505.      N > 0 -> $dec_xform_1(Body0,C,Body1) ; Body0 = Body1.
  506.  
  507. $dec_xform_1(','(A0,A1,A2,A3),C,(B0,B1,B2,B3)) :-
  508.      !,
  509.      $dec_xform_1(A0,C,B0),
  510.      $dec_xform_1(A1,C,B1),
  511.      $dec_xform_1(A2,C,B2),
  512.      $dec_xform_1(A3,C,B3).
  513. $dec_xform_1(','(A0,A1),C,','(B0,B1)) :-
  514.      !,
  515.      $dec_xform_1(A0,C,B0),
  516.      $dec_xform_1(A1,C,B1).
  517. $dec_xform_1(';'(A0,A1),C,';'(B0,B1)) :-
  518.      !,
  519.      $dec_xform_1(A0,C,B0),
  520.      $dec_xform_1(A1,C,B1).
  521. $dec_xform_1('->'(A0,A1),C,'->'(B0,B1)) :-
  522.      !,
  523.      $dec_xform_1(A0,C,B0),
  524.      $dec_xform_1(A1,C,B1).
  525. $dec_xform_1('_$cutto'(V),C,Lit) :-
  526.      !,
  527.      (C == V -> Lit = '!' ; Lit = '_$cutto'(V)).
  528. $dec_xform_1(L,_,L).
  529.  
  530.  
  531. $dec_errmsg(Type,P,N) :-
  532.      $telling(X), $tell(stderr),
  533.      $writename('*** Warning: '),
  534.      $writename(P), $writename('/'), $writename(N),
  535.      $dec_errmsg1(Type, ErrType),
  536.      $writename(ErrType), $writename(', cannot decompile ***'), $nl,
  537.      $told, $tell(X).
  538.  
  539. $dec_errmsg1(0, ' is undefined').
  540. $dec_errmsg1(2, ' is compiled').
  541.  
  542. /*  The following predicates manipulate a "register map", which is
  543.     basically an array of 256 elements represented as a complete quadtree
  544.     of height 4.                            */
  545.  
  546. $dec_mk_rmap(Level,Arity,Map) :-
  547.      $functor(Map,rm,Arity),
  548.      (Level =:= 1 ->
  549.          true ;
  550.      (Lev1 is Level - 1,
  551.       $dec_mk_rmaps(Arity,Arity,Lev1,Map)
  552.      )
  553.      ).
  554.  
  555. $dec_mk_rmaps(Argno,Arity,Level,Map) :-
  556.      Argno =:= 0 ->
  557.          true ;
  558.      (arg(Argno,Map,SubMap),
  559.       $dec_mk_rmap(Level,Arity,SubMap),
  560.       NextArg is Argno - 1,
  561.       $dec_mk_rmaps(NextArg,Arity,Level,Map)
  562.      ).
  563.  
  564. $dec_map_lookup(I,Tree,Val) :-
  565.      Index is I - 1,
  566.      $dec_map_lookup(4,Index,Tree,Val).
  567.  
  568. $dec_map_lookup(Level,Index,Tree,Val) :-
  569.     $get_currindex(Level,Index,CurrInd),
  570.     (Level =:= 1 ->
  571.          arg(CurrInd,Tree,Val) ;
  572.      (arg(CurrInd,Tree,SubTree),
  573.       NewLevel is Level - 1,
  574.       $dec_map_lookup(NewLevel,Index,SubTree,Val)
  575.      )
  576.     ).
  577.  
  578. $dec_map_update(I,Tree,Val,NTree) :-
  579.      Index is I-1,
  580.      $dec_map_update(4,Index,Tree,Val,NTree).
  581.  
  582. $dec_map_update(Level,Index,Tree,Val,NTree) :-
  583.     NTree = rm(_,_,_,_),
  584.     $get_currindex(Level,Index,CurrInd),
  585.     (Level =:= 1 ->
  586.      $subst_arg(4,CurrInd,Tree,Val,NTree) ;
  587.      (arg(CurrInd,Tree,SubTree),
  588.       NewLevel is Level - 1,
  589.       $dec_map_update(NewLevel,Index,SubTree,Val,NSubTree),
  590.       $subst_arg(4,CurrInd,Tree,NSubTree,NTree)
  591.      )
  592.      ).
  593.  
  594. $subst_arg(N,I,Tree,Val,NTree) :-
  595.      N =:= 0 ->                /* done! */
  596.           true ;
  597.       ((N =:= I ->            /* make the change */
  598.            arg(N,NTree,Val) ;
  599.            (arg(N,Tree,Arg), arg(N,NTree,Arg))
  600.            ),
  601.        N1 is N - 1,
  602.        $subst_arg(N1,I,Tree,Val,NTree)
  603.       ).
  604.  
  605. $get_currindex(Level,Index,N) :-
  606.     Shift is (Level-1) << 1,  /* Shift = 2*(Level-1) */
  607.     Mask is 2'11 << Shift,
  608.     N is ((Index /\ Mask) >> Shift) + 1.
  609.  
  610. $dec_copyargs(N,T1,T2) :-
  611.      N =:= 0 ->
  612.           true ;
  613.       (arg(N,T1,X), arg(N,T2,X),
  614.        N1 is N - 1,
  615.        $dec_copyargs(N1,T1,T2)
  616.       ).
  617.  
  618. /* ----------------------------- $decompile.P ----------------------------- */
  619.  
  620.